home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / code / package.lisp < prev    next >
Encoding:
Text File  |  1992-05-30  |  49.3 KB  |  1,427 lines
  1. ;;; -*- Log: code.log; Package: Lisp -*-
  2. ;;;
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the CMU Common Lisp project at
  5. ;;; Carnegie Mellon University, and has been placed in the public domain.
  6. ;;; If you want to use this code or any part of CMU Common Lisp, please contact
  7. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
  8. ;;;
  9. (ext:file-comment
  10.   "$Header: package.lisp,v 1.17 92/03/13 23:27:54 ram Exp $")
  11. ;;;
  12. ;;; **********************************************************************
  13. ;;;
  14. ;;;     Package stuff and stuff like that.
  15. ;;;
  16. ;;; Re-Written by Rob MacLachlan.  Earlier version written by
  17. ;;; Lee Schumacher.  Apropos & iteration macros courtesy of Skef Wholey.
  18. ;;; Defpackage by Dan Zigmond.  With-Package-Iterator by Blaine Burks. 
  19. ;;;
  20. (in-package 'lisp)
  21. (export '(package packagep *package* make-package in-package find-package
  22.       package-name package-nicknames rename-package
  23.       package-use-list package-used-by-list package-shadowing-symbols
  24.       list-all-packages intern find-symbol unintern export
  25.       unexport import shadowing-import shadow use-package
  26.       unuse-package find-all-symbols do-symbols with-package-iterator
  27.       do-external-symbols do-all-symbols apropos apropos-list defpackage))
  28.  
  29. (in-package "EXTENSIONS")
  30. (export '(*keyword-package* *lisp-package*))
  31. (in-package 'lisp)
  32.  
  33.  
  34. (defstruct (package
  35.         (:constructor internal-make-package)
  36.         (:predicate packagep)
  37.         (:print-function
  38.          (lambda (s stream d)
  39.            (declare (ignore d) (stream stream))
  40.            (multiple-value-bind (iu it) (internal-symbol-count s)
  41.          (multiple-value-bind (eu et) (external-symbol-count s)
  42.            (format stream
  43.                "#<The ~A package, ~D/~D internal, ~D/~D external>"
  44.                (package-%name s) iu it eu et)))))
  45.         (:make-load-form-fun
  46.          (lambda (package)
  47.            (values `(package-or-lose ',(package-name package))
  48.                nil))))
  49.   "Standard structure for the description of a package.  Consists of 
  50.    a list of all hash tables, the name of the package, the nicknames of
  51.    the package, the use-list for the package, the used-by- list, hash-
  52.    tables for the internal and external symbols, and a list of the
  53.    shadowing symbols."
  54.   (tables (list nil))    ; A list of all the hashtables for inherited symbols.
  55.   %name            ; The string name of the package.
  56.   %nicknames        ; List of nickname strings.
  57.   (%use-list ())        ; List of packages we use.
  58.   (%used-by-list ())    ; List of packages that use this package.
  59.   internal-symbols    ; Hashtable of internal symbols.
  60.   external-symbols    ; Hashtable of external symbols.
  61.   (%shadowing-symbols ())) ; List of shadowing symbols.
  62.  
  63. (macrolet ((frob (ext real)
  64.          `(defun ,ext (x) (,real (package-or-lose x)))))
  65.   (frob package-name package-%name)
  66.   (frob package-nicknames package-%nicknames)
  67.   (frob package-use-list package-%use-list)
  68.   (frob package-used-by-list package-%used-by-list)
  69.   (frob package-shadowing-symbols package-%shadowing-symbols))
  70.  
  71. (defvar *package* () "The current package.")
  72.  
  73. ;;; An equal hashtable from package names to packages.
  74. ;;;
  75. (defvar *package-names* (make-hash-table :test #'equal))
  76.  
  77.  
  78. ;;; Lots of people want the keyword package and Lisp package without a lot
  79. ;;; of fuss, so we give them their own variables.
  80. ;;;
  81. (defvar *lisp-package*)
  82. (defvar *keyword-package*)
  83.  
  84.  
  85. ;;; This magical variable is T during initialization so Use-Package's of packages
  86. ;;; that don't yet exist quietly win.  Such packages are thrown onto the list
  87. ;;; *Deferred-Use-Packages* so that this can be fixed up later.
  88.  
  89. (defvar *in-package-init* nil)
  90. (defvar *deferred-use-packages* nil)
  91.  
  92. ;;; Find-Package  --  Public
  93. ;;;
  94. ;;;
  95. (defun find-package (name)
  96.   "Find the package having the specified name."
  97.   (values (gethash (string name) *package-names*)))
  98.  
  99. ;;; Package-Listify  --  Internal
  100. ;;;
  101. ;;;    Return a list of packages given a package-or-string-or-symbol or
  102. ;;; list thereof, or die trying.
  103. ;;;
  104. (defun package-listify (thing)
  105.   (let ((res ()))
  106.     (dolist (thing (if (listp thing) thing (list thing)) res)
  107.       (push (package-or-lose thing) res))))
  108.  
  109. ;;; Package-Or-Lose  --  Internal
  110. ;;;
  111. ;;;    Take a package-or-string-or-symbol and return a package.
  112. ;;;
  113. (defun package-or-lose (thing)
  114.   (if (packagep thing)
  115.       thing
  116.       (let ((thing (string thing)))
  117.     (cond ((gethash thing *package-names*))
  118.           (t
  119.            (cerror "Make this package."
  120.                "~S is not the name of a package." thing)
  121.            (make-package thing))))))
  122.  
  123.  
  124. ;;;; Package-Hashtables
  125. ;;;
  126. ;;;    Packages are implemented using a special kind of hashtable.  It is
  127. ;;; an open hashtable with a parallel 8-bit I-vector of hash-codes.  The
  128. ;;; primary purpose of the hash for each entry is to reduce paging by
  129. ;;; allowing collisions and misses to be detected without paging in the
  130. ;;; symbol and pname for an entry.  If the hash for an entry doesn't
  131. ;;; match that for the symbol that we are looking for, then we can
  132. ;;; go on without touching the symbol, pname, or even hastable vector.
  133. ;;;    It turns out that, contrary to my expectations, paging is a very
  134. ;;; important consideration the design of the package representation.
  135. ;;; Using a similar scheme without the entry hash, the fasloader was
  136. ;;; spending more than half its time paging in INTERN.
  137. ;;;    The hash code also indicates the status of an entry.  If it zero,
  138. ;;; the the entry is unused.  If it is one, then it is deleted.
  139. ;;; Double-hashing is used for collision resolution.
  140.  
  141. (defstruct (package-hashtable
  142.         (:constructor internal-make-package-hashtable ())
  143.         (:copier nil)
  144.         (:print-function
  145.          (lambda (table stream d)
  146.            (declare (ignore d))
  147.            (format stream
  148.                "#<Package-Hashtable: Size = ~D, Free = ~D, Deleted = ~D>"
  149.                (package-hashtable-size table)
  150.                (package-hashtable-free table)
  151.                (package-hashtable-deleted table)))))
  152.   table        ; The g-vector of symbols.
  153.   hash        ; The i-vector of pname hash values.
  154.   size        ; The maximum number of entries allowed.
  155.   free        ; The entries that can be made before we have to rehash.
  156.   deleted)    ; The number of deleted entries.
  157.  
  158.  
  159. ;;; The maximum density we allow in a package hashtable.
  160. ;;;
  161. (defparameter package-rehash-threshold 3/4)
  162.  
  163. ;;; Entry-Hash  --  Internal
  164. ;;;
  165. ;;;    Compute a number from the sxhash of the pname and the length which
  166. ;;; must be between 2 and 255.
  167. ;;;
  168. (defmacro entry-hash (length sxhash)
  169.   `(the fixnum (+ (the fixnum (rem (the fixnum (logxor ,length
  170.                                ,sxhash
  171.                                (the fixnum (ash ,sxhash -8))
  172.                                (the fixnum (ash ,sxhash -16))
  173.                                (the fixnum (ash ,sxhash -19))))
  174.                    254))
  175.           2)))
  176.  
  177. ;;; Make-Package-Hashtable  --  Internal
  178. ;;;
  179. ;;;    Make a package hashtable having a prime number of entries at least
  180. ;;; as great as (/ size package-rehash-threshold).  If Res is supplied,
  181. ;;; then it is destructively modified to produce the result.  This is
  182. ;;; useful when changing the size, since there are many pointers to
  183. ;;; the hashtable.
  184. ;;;
  185. (defun make-package-hashtable (size &optional
  186.                     (res (internal-make-package-hashtable)))
  187.   (do ((n (logior (truncate size package-rehash-threshold) 1)
  188.       (+ n 2)))
  189.       ((primep n)
  190.        (setf (package-hashtable-table res)
  191.          (make-array n))
  192.        (setf (package-hashtable-hash res)
  193.          (make-array n :element-type '(unsigned-byte 8) :initial-element 0))
  194.        (let ((size (truncate (* n package-rehash-threshold))))
  195.      (setf (package-hashtable-size res) size)
  196.      (setf (package-hashtable-free res) size))
  197.        (setf (package-hashtable-deleted res) 0)
  198.        res)
  199.     (declare (fixnum n))))
  200.  
  201.  
  202. ;;; Internal-Symbol-Count, External-Symbols-Count  --  Internal
  203. ;;;
  204. ;;;    Return internal and external symbols.  Used by Genesis and stuff.
  205. ;;;
  206. (flet ((stuff (table)
  207.           (let ((size (the fixnum (- (the fixnum (package-hashtable-size table))
  208.                      (the fixnum (package-hashtable-deleted table))))))
  209.         (declare (fixnum size))
  210.         (values (the fixnum (- size (the fixnum (package-hashtable-free table)))) size))))
  211.  
  212.   (defun internal-symbol-count (package)
  213.     (stuff (package-internal-symbols package)))
  214.  
  215.   (defun external-symbol-count (package)
  216.     (stuff (package-external-symbols package))))
  217.  
  218.  
  219. ;;; Add-Symbol  --  Internal
  220. ;;;
  221. ;;;    Add a symbol to a package hashtable.  The symbol is assumed
  222. ;;; not to be present.
  223. ;;;
  224. (defun add-symbol (table symbol)
  225.   (let* ((vec (package-hashtable-table table))
  226.      (hash (package-hashtable-hash table))
  227.      (len (length vec))
  228.      (sxhash (%sxhash-simple-string (symbol-name symbol)))
  229.      (h2 (the fixnum (1+ (the fixnum (rem sxhash
  230.                           (the fixnum (- len 2))))))))
  231.     (declare (simple-vector vec)
  232.          (type (simple-array (unsigned-byte 8)) hash)
  233.          (fixnum len sxhash h2))
  234.     (cond ((zerop (the fixnum (package-hashtable-free table)))
  235.        (make-package-hashtable (the fixnum
  236.                     (* (the fixnum
  237.                         (package-hashtable-size table))
  238.                        2))
  239.                    table)
  240.        (add-symbol table symbol)
  241.        (dotimes (i len)
  242.          (declare (fixnum i))
  243.          (when (> (the fixnum (aref hash i)) 1)
  244.            (add-symbol table (svref vec i)))))
  245.       (t
  246.        (do ((i (rem sxhash len) (rem (+ i h2) len)))
  247.            ((< (the fixnum (aref hash i)) 2)
  248.         (if (zerop (the fixnum (aref hash i)))
  249.             (decf (the fixnum (package-hashtable-free table)))
  250.             (decf (the fixnum (package-hashtable-deleted table))))
  251.         (setf (svref vec i) symbol)
  252.         (setf (aref hash i)
  253.               (entry-hash (length (the simple-string (symbol-name symbol)))
  254.                   sxhash)))
  255.          (declare (fixnum i)))))))
  256.  
  257. ;;; With-Symbol  --  Internal
  258. ;;;
  259. ;;;    Find where the symbol named String is stored in Table.  Index-Var
  260. ;;; is bound to the index, or NIL if it is not present.  Symbol-Var
  261. ;;; is bound to the symbol.  Length and Hash are the length and sxhash
  262. ;;; of String.  Entry-Hash is the entry-hash of the string and length.
  263. ;;;
  264. (defmacro with-symbol ((index-var symbol-var table string length sxhash
  265.                   entry-hash)
  266.                &body forms)
  267.   (let ((vec (gensym)) (hash (gensym)) (len (gensym)) (h2 (gensym))
  268.     (name (gensym)) (name-len (gensym)) (ehash (gensym)))
  269.     `(let* ((,vec (package-hashtable-table ,table))
  270.         (,hash (package-hashtable-hash ,table))
  271.         (,len (length ,vec))
  272.         (,h2 (1+ (the fixnum (rem (the fixnum ,sxhash)
  273.                       (the fixnum (- ,len 2)))))))
  274.        (declare (type (simple-array (unsigned-byte 8) (*)) ,hash)
  275.         (simple-vector ,vec)
  276.         (fixnum ,len ,h2))
  277.        (prog ((,index-var (rem (the fixnum ,sxhash) ,len))
  278.           ,symbol-var ,ehash)
  279.      (declare (type (or fixnum null) ,index-var))
  280.      LOOP
  281.      (setq ,ehash (aref ,hash ,index-var))
  282.      (cond ((eql ,ehash ,entry-hash)
  283.         (setq ,symbol-var (svref ,vec ,index-var))
  284.         (let* ((,name (symbol-name ,symbol-var))
  285.                (,name-len (length ,name)))
  286.           (declare (simple-string ,name)
  287.                (fixnum ,name-len))
  288.           (when (and (= ,name-len ,length)
  289.                  (string= ,string ,name  :end1 ,length
  290.                       :end2 ,name-len))
  291.             (go DOIT))))
  292.            ((zerop ,ehash)
  293.         (setq ,index-var nil)
  294.         (go DOIT)))
  295.      (setq ,index-var (+ ,index-var ,h2))
  296.      (when (>= ,index-var ,len)
  297.        (setq ,index-var (- ,index-var ,len)))
  298.      (go LOOP)
  299.      DOIT
  300.      (return (progn ,@forms))))))
  301.  
  302. ;;; Nuke-Symbol  --  Internal
  303. ;;;
  304. ;;;    Delete the entry for String in Table.  The entry must exist.
  305. ;;;
  306. (defun nuke-symbol (table string)
  307.   (declare (simple-string string))
  308.   (let* ((length (length string))
  309.      (hash (%sxhash-simple-string string))
  310.      (ehash (entry-hash length hash)))
  311.     (declare (fixnum length hash))
  312.     (with-symbol (index symbol table string length hash ehash)
  313.       (setf (aref (package-hashtable-hash table) index) 1)
  314.       (setf (aref (package-hashtable-table table) index) nil)
  315.       (incf (package-hashtable-deleted table)))))
  316.  
  317. ;;;; Iteration macros.
  318.  
  319. ;;; Instead of using slow, silly successor functions, we make the iteration
  320. ;;; guys be big PROG's.  Yea!
  321.  
  322. (eval-when (compile load eval)
  323.  
  324. (defun make-do-symbols-vars ()
  325.   `(,(gensym)                    ; index
  326.     ,(gensym)                    ; hash
  327.     ,(gensym)                    ; hash-vector
  328.     ,(gensym)))                    ; terminus
  329.  
  330. (defun make-do-symbols-code (vars var hash-table exit-form forms)
  331.   (let ((index (first vars))
  332.     (hash-vector (second vars))
  333.     (hash (third vars))
  334.     (terminus (fourth vars))
  335.     (TOP (gensym)))
  336.     `((setq ,index 0)
  337.       (setq ,hash-vector (package-hashtable-table ,hash-table))
  338.       (setq ,hash (package-hashtable-hash ,hash-table))
  339.       (setq ,terminus (length (the simple-vector ,hash-vector)))
  340.       ,TOP
  341.       (if (= (the fixnum ,index) (the fixnum ,terminus))
  342.       ,exit-form)
  343.       (when (> (the fixnum (aref (the (simple-array (unsigned-byte 8)) ,hash)
  344.                  ,index))
  345.            1)
  346.     (setq ,var (svref ,hash-vector ,index))
  347.     ,@forms)
  348.       (incf ,index)
  349.       (go ,TOP))))
  350.  
  351. ); eval-when (compile load eval)
  352.  
  353. (defmacro do-symbols ((var &optional (package '*package*) result-form)
  354.               &body (code decls))
  355.   "Do-Symbols (Var [Package [Result-Form]]) {Declaration}* {Tag | Statement}*
  356.   Executes the Forms at least once for each symbol accessible in the given
  357.   Package with Var bound to the current symbol."
  358.   (let* ((DONE-INTERNAL (gensym))
  359.      (DONE-EXTERNAL (gensym))
  360.      (NEXT-INHERIT (gensym))
  361.      (vars (make-do-symbols-vars))
  362.      (n-package (gensym))
  363.      (shadowed (gensym))
  364.      (inherits (gensym))
  365.      (this-inherit (gensym)))
  366.     `(prog* ((,n-package (package-or-lose ,package))
  367.          (,shadowed (package-%shadowing-symbols ,n-package))
  368.          (,inherits (package-%use-list ,n-package))
  369.          ,var ,@vars ,this-inherit)
  370.        ,@decls
  371.        ,@(make-do-symbols-code
  372.       vars var `(package-internal-symbols ,n-package)
  373.       `(go ,DONE-INTERNAL)
  374.       code)
  375.        ,DONE-INTERNAL
  376.  
  377.        ,@(make-do-symbols-code
  378.       vars var `(package-external-symbols ,n-package)
  379.       `(go ,DONE-EXTERNAL)
  380.       code)
  381.        ,DONE-EXTERNAL
  382.  
  383.        ,NEXT-INHERIT
  384.        (when (null ,inherits)
  385.      (setq ,var nil)
  386.      (return ,result-form))
  387.  
  388.        (setq ,this-inherit (package-external-symbols (car ,inherits)))
  389.        ,@(make-do-symbols-code
  390.       vars var this-inherit
  391.       `(progn
  392.         (setq ,inherits (cdr ,inherits))
  393.         (go ,NEXT-INHERIT))
  394.       `((when (or (not ,shadowed)
  395.               (eq (find-symbol (symbol-name ,var) ,n-package) ,var))
  396.           ,@code))))))
  397.  
  398. (defmacro do-external-symbols ((var &optional (package '*package*) result-form)
  399.                    &body (code decls))
  400.   "Do-External-Symbols (Var [Package [Result-Form]])
  401.                        {Declaration}* {Tag | Statement}*
  402.   Executes the Forms once for each external symbol in the given Package with
  403.   Var bound to the current symbol."
  404.   (let ((vars (make-do-symbols-vars))
  405.     (n-package (gensym)))
  406.     `(prog ((,n-package (package-or-lose ,package))
  407.         ,var ,@vars)
  408.        ,@decls
  409.        ,@(make-do-symbols-code
  410.       vars var `(package-external-symbols ,n-package)
  411.       `(return (progn (setq ,var nil) ,result-form))
  412.       code))))
  413.  
  414. (defmacro do-all-symbols ((var &optional result-form)
  415.               &body (code decls))
  416.   "Do-All-Symbols (Var [Result-Form]) {Declaration}* {Tag | Statement}*
  417.   Executes the Forms once for each symbol in each package with Var bound
  418.   to the current symbol."
  419.   (let* ((PACKAGE-LOOP (gensym))
  420.      (TAG (gensym))
  421.      (package-list (gensym))
  422.      (vars (make-do-symbols-vars))
  423.      (internal-code (make-do-symbols-code
  424.              vars var `(package-internal-symbols (car ,package-list))
  425.              `(go ,TAG)
  426.              code))
  427.      (external-code (make-do-symbols-code
  428.              vars var `(package-external-symbols (car ,package-list))
  429.              `(progn (setq ,package-list (cdr ,package-list))
  430.                  (go ,PACKAGE-LOOP))
  431.              code)))
  432.     `(prog (,package-list ,var ,@vars)
  433.        ,@decls
  434.        (setq ,package-list (list-all-packages))
  435.       ,PACKAGE-LOOP
  436.        (when (null ,package-list)
  437.      (setq ,var nil)
  438.      (return ,result-form))
  439.        ,@internal-code
  440.       ,TAG
  441.        ,@external-code)))
  442.  
  443. ;;;; WITH-PACKAGE-ITERATOR
  444.  
  445. (defmacro with-package-iterator ((mname package-list &rest symbol-types)
  446.                  &body body)
  447.   (let* ((packages (gensym))
  448.      (these-packages (gensym))
  449.      (ordered-types (let ((res nil))
  450.               (dolist (kind '(:inherited :external :internal)
  451.                     res)
  452.                 (when (member kind symbol-types)
  453.                   (push kind res)))))  ; Order symbol-types.
  454.      (counter (gensym))
  455.      (kind (gensym))
  456.      (hash-vector (gensym))
  457.      (vector (gensym))
  458.      (package-use-list (gensym))
  459.      (init-macro (gensym))
  460.      (end-test-macro (gensym))
  461.      (real-symbol-p (gensym))
  462.      (BLOCK (gensym)))
  463.     `(let* ((,these-packages ,package-list)
  464.         (,packages `,(mapcar #'(lambda (package)
  465.                      (if (packagep package)
  466.                      package
  467.                      (find-package package)))
  468.                  (if (consp ,these-packages)
  469.                      ,these-packages
  470.                      (list ,these-packages))))
  471.         (,counter nil)
  472.         (,kind (car ,packages))
  473.         (,hash-vector nil)
  474.         (,vector nil)
  475.         (,package-use-list nil))
  476.        ,(if (member :inherited ordered-types)
  477.         `(setf ,package-use-list (package-%use-list (car ,packages)))
  478.         `(declare (ignore ,package-use-list)))
  479.        (macrolet ((,init-macro (next-kind)
  480.       (let ((symbols (gensym)))
  481.        `(progn
  482.           (setf ,',kind ,next-kind)
  483.           (setf ,',counter nil)
  484.           ,(case next-kind
  485.          (:internal
  486.           `(let ((,symbols (package-internal-symbols
  487.                     (car ,',packages))))
  488.              (setf ,',vector (package-hashtable-table ,symbols))
  489.              (setf ,',hash-vector (package-hashtable-hash ,symbols))))
  490.          (:external
  491.           `(let ((,symbols (package-external-symbols
  492.                     (car ,',packages))))
  493.              (setf ,',vector (package-hashtable-table ,symbols))
  494.              (setf ,',hash-vector (package-hashtable-hash ,symbols))))
  495.          (:inherited
  496.           `(let ((,symbols (package-external-symbols
  497.                     (car ,',package-use-list))))
  498.              (setf ,',vector (package-hashtable-table ,symbols))
  499.              (setf ,',hash-vector (package-hashtable-hash ,symbols))))))))
  500.           (,end-test-macro (this-kind)
  501.              `,(let ((next-kind (cadr (member this-kind
  502.                               ',ordered-types))))
  503.              (if next-kind
  504.                  `(,',init-macro ,next-kind)
  505.                  `(if (endp (setf ,',packages (cdr ,',packages)))
  506.                   (return-from ,',BLOCK)
  507.                   (,',init-macro ,(car ',ordered-types)))))))
  508.      (when ,packages
  509.        ,(when (null symbol-types)
  510.           (error "Must supply at least one of :internal, :external, or ~
  511.           :inherited."))
  512.        ,(dolist (symbol symbol-types)
  513.           (unless (member symbol '(:internal :external :inherited))
  514.         (error "~S is not one of :internal, :external, or :inherited."
  515.                symbol)))
  516.        (,init-macro ,(car ordered-types))
  517.        (flet ((,real-symbol-p (number)
  518.             (> number 1)))
  519.          (macrolet ((,mname ()
  520.           `(block ,',BLOCK
  521.          (loop
  522.            (case ,',kind
  523.              ,@(when (member :internal ',ordered-types)
  524.              `((:internal
  525.                 (setf ,',counter
  526.                   (position-if #',',real-symbol-p ,',hash-vector
  527.                            :start (if ,',counter
  528.                               (1+ ,',counter)
  529.                               0)))
  530.                 (if ,',counter
  531.                 (return-from ,',BLOCK
  532.                  (values t (svref ,',vector ,',counter)
  533.                      ,',kind (car ,',packages)))
  534.                 (,',end-test-macro :internal)))))
  535.              ,@(when (member :external ',ordered-types)
  536.              `((:external
  537.                 (setf ,',counter
  538.                   (position-if #',',real-symbol-p ,',hash-vector
  539.                            :start (if ,',counter
  540.                               (1+ ,',counter)
  541.                               0)))
  542.                 (if ,',counter
  543.                 (return-from ,',BLOCK
  544.                  (values t (svref ,',vector ,',counter)
  545.                      ,',kind (car ,',packages)))
  546.                 (,',end-test-macro :external)))))
  547.              ,@(when (member :inherited ',ordered-types)
  548.              `((:inherited
  549.                 (setf ,',counter
  550.                   (position-if #',',real-symbol-p ,',hash-vector
  551.                            :start (if ,',counter
  552.                               (1+ ,',counter)
  553.                               0)))
  554.                 (cond (,',counter
  555.                    (return-from
  556.                     ,',BLOCK
  557.                     (values t (svref ,',vector ,',counter)
  558.                         ,',kind (car ,',packages))))
  559.                   (t
  560.                    (setf ,',package-use-list
  561.                      (cdr ,',package-use-list))
  562.                    (cond ((endp ,',package-use-list)
  563.                       (setf ,',packages (cdr ,',packages))
  564.                       (when (endp ,',packages)
  565.                         (return-from ,',BLOCK))
  566.                       (setf ,',package-use-list
  567.                         (package-%use-list
  568.                          (car ,',packages)))
  569.                       (,',init-macro ,(car ',ordered-types)))
  570.                      (t (,',init-macro :inherited)
  571.                         (setf ,',counter nil)))))))))))))
  572.            ,@body)))))))
  573.  
  574.  
  575. ;;;; DEFPACKAGE:
  576.  
  577. (defmacro defpackage (package &rest arguments)
  578.   "Defines a new package called PACKAGE.  ARGUMENTS should a list of forms,
  579.    each of with is one of:
  580.        (:SIZE <integer>)
  581.        (:NICKNAMES {package-name}*)
  582.        (:SHADOW {symbol-name}*)
  583.        (:SHADOWING-IMPORT-FROM <package-name> {symbol-name}*)
  584.        (:USE {package-name}*)
  585.        (:IMPORT-FROM <package-name> {symbol-name}*)
  586.        (:INTERN {symbol-name}*)
  587.        (:EXPORT {symbol-name}*)
  588.    All keywords except :SIZE can be used multiple times."
  589.   (let ((body nil)
  590.     (package-name
  591.      (etypecase package
  592.        ;; Make sure we have a good package name to use.
  593.        (string package)
  594.        (symbol (symbol-name package)))))
  595.     (multiple-value-bind
  596.     (nicknames uses shadows imports shadowed-imports exports interns size)
  597.     (parse-defpackage-keywords arguments package-name)
  598.       ;; We set up the body of the form to return first things first
  599.       ;; for readability, even though (since we're using PUSH) we
  600.       ;; then have to NREVERSE at the end.  The order of operations
  601.       ;; must be: 1. :shadow and :shadowing-import-from
  602.       ;;          2. :use
  603.       ;;          3. :import-from and :return
  604.       ;;          4. :export
  605.       (when shadows
  606.     (push `(shadow (list ,@shadows) ,package-name)
  607.           body))
  608.       (when shadowed-imports
  609.     (push `(shadowing-import (list ,@shadowed-imports) ,package-name)
  610.           body))
  611.       (when uses
  612.     (push `(use-package (list ,@uses) ,package-name)
  613.           body))
  614.       (when imports
  615.     (push `(import (list ,@imports) ,package-name)
  616.           body))
  617.       (when interns
  618.     (dolist (symbol interns)
  619.       (push `(intern ,symbol ,package-name)
  620.         body)))
  621.       (when exports
  622.     (push `(export (list ,@exports) ,package-name)
  623.           body))
  624.       ;;
  625.       ;; We do :nicknames and :sizeat the top (where it's convenient).
  626.       ;; :Size is not implemented very well.  We assume, for absolutely
  627.       ;; no good reason, that approximates 1/5 of the symbols in a
  628.       ;; package will be external.
  629.       `(progn
  630.      (eval-when (compile load eval)
  631.        (unless (find-package ,package-name)
  632.          (make-package
  633.           ,package-name
  634.           ,@(if nicknames `(:nicknames (list ,@nicknames)))
  635.           ,@(if size `(:internal-symbols ,(round size 5/4)
  636.                :external-symbols ,(round size 5))))))
  637.      ,@(nreverse body)
  638.      (find-package ,package-name)))))
  639.  
  640.  
  641. (defun parse-defpackage-keywords (rest-list n-package)
  642.   "Parses the arguments to DEFPACKAGE.  Returns eight arguments:
  643.        1. A list of the package's nicknames.
  644.        2. A list of the other packages that this package uses.
  645.        3. A list of shadows.
  646.        4. A list of lists of the form (package-name {symbol-name}*)
  647.           describing the symbols to be imported from package-name
  648.       and placed on the shadowed symbols list.
  649.        5. A list of lists as above of symbols to be imported.
  650.        6. A list of symbols to export.
  651.        7. A list of symbols to intern.
  652.        8. The declared size of the package.
  653.    Nil is returned as any of these eight values if no value is provided
  654.    by the user.  Only mimimal error checking is done here."
  655.   (do* ((symbols-in nil)
  656.     (symbols-out)
  657.     (nicknames nil)
  658.     (uses nil)
  659.     (shadows nil)
  660.     (imports nil)
  661.     (shadowed-imports nil)
  662.     (exports nil)
  663.     (interns nil)
  664.     (size nil)
  665.     (remaining-args rest-list (rest remaining-args))
  666.     (current-keyword (first (first remaining-args))
  667.              (first (first remaining-args)))
  668.     (current-args (rest (first remaining-args))
  669.               (rest (first remaining-args))))
  670.        ((endp remaining-args)
  671.     (values nicknames
  672.         uses
  673.         shadows
  674.         imports
  675.         shadowed-imports
  676.         exports
  677.         interns
  678.         size))
  679.     (case current-keyword
  680.       (:nicknames
  681.        (setf nicknames (append nicknames (stringify-symbols current-args))))
  682.       (:use
  683.        (setf uses (append uses (stringify-symbols current-args))))
  684.       (:shadow
  685.        (setf current-args (stringify-symbols current-args))
  686.        (setf symbols-in (append-but-lose-if-overlap symbols-in current-args))
  687.        (dolist (string current-args)
  688.      (push string shadows)))
  689.       (:shadowing-import-from
  690.        (setf current-args (stringify-symbols current-args))
  691.        (setf symbols-in (append-but-lose-if-overlap symbols-in
  692.                             (rest current-args)))
  693.        (dolist (string (rest current-args))
  694.      (push `(find-symbol-or-lose ,string ,(first current-args))
  695.            shadowed-imports)))
  696.       (:import-from
  697.        (setf current-args (stringify-symbols current-args))
  698.        (setf symbols-in (append-but-lose-if-overlap symbols-in
  699.                             (rest current-args)))
  700.        (dolist (string (rest current-args))
  701.      (push `(find-symbol-or-lose ,string ,(first current-args))
  702.            imports)))
  703.       (:export
  704.        (setf symbols-out (append-but-lose-if-overlap symbols-out
  705.                              (rest current-args)))
  706.        (dolist (string (stringify-symbols current-args))
  707.      (push `(intern ,string ,n-package)
  708.            exports)))
  709.       (:intern
  710.        (setf current-args (stringify-symbols current-args))
  711.        (setf symbols-in (append-but-lose-if-overlap symbols-in current-args))
  712.        (setf symbols-out (append-but-lose-if-overlap symbols-out current-args))
  713.        (setf interns (append interns current-args)))
  714.       (:size
  715.        (if (null size)
  716.        (if (= (length current-args) 1)
  717.            (setf size (first current-args))
  718.            (error "Too many arguments to :SIZE keyword in DEFPACAKGE."))
  719.        (error ":SIZE keyword used more than once in DEFPACKAGE.")))
  720.       (otherwise
  721.        (error "Bad keyword passed to DEFPACKAGE: ~S." current-keyword)))))
  722.  
  723. (defun find-symbol-or-lose (symbol package)
  724.   "Tries to find SYMBOL in PACKAGE, but signals a continuable error if
  725.    it's not there."
  726.   (multiple-value-bind (sym how)
  727.                (find-symbol symbol package)
  728.     (cond ((not how)
  729.        (cerror "INTERN this symbol."
  730.            "Can't find the symbol named ~S in ~S."
  731.            symbol package)
  732.        (values (intern symbol package)))
  733.       (t sym))))
  734.  
  735. (defun stringify-symbols (symbols)
  736.   "Takes a list of symbols and/or strings and returns a list of
  737.    strings using SYMBOL-NAME for any necessary coersion."
  738.   (mapcar #'(lambda (x)
  739.           (etypecase x
  740.         (string x)
  741.         (symbol (symbol-name x))))
  742.       symbols))
  743.  
  744. (defun append-but-lose-if-overlap (list-one list-two &key (test #'string=))
  745.   "APPENDs two lists but screams if they intersect at all.
  746.    Uses STRING= as default test because that's what DEFPACKAGE wants to use."
  747.   (if (intersection list-one list-two :test test)
  748.       (error "Overlap found in argument lists.")
  749.       (append list-one list-two)))
  750.  
  751.  
  752. ;;; Enter-New-Nicknames  --  Internal
  753. ;;;
  754. ;;;    Enter any new Nicknames for Package into *package-names*.
  755. ;;; If there is a conflict then give the user a chance to do
  756. ;;; something about it.
  757. ;;;
  758. (defun enter-new-nicknames (package nicknames)
  759.   (check-type nicknames list)
  760.   (dolist (n nicknames)
  761.     (let* ((n (string n))
  762.        (found (gethash n *package-names*)))
  763.       (cond ((not found)
  764.          (setf (gethash n *package-names*) package)
  765.          (push n (package-%nicknames package)))
  766.         ((eq found package))
  767.         ((string= (package-%name found) n)
  768.          (cerror "Ignore this nickname."
  769.              "~S is a package name, so it cannot be a nickname for ~S."
  770.              n (package-%name package)))
  771.         (t
  772.          (cerror "Redefine this nickname."
  773.              "~S is already a nickname for ~S."
  774.              n (package-%name found))
  775.          (setf (gethash n *package-names*) package)
  776.          (push n (package-%nicknames package)))))))
  777.  
  778.  
  779. ;;; Make-Package  --  Public
  780. ;;;
  781. ;;;    Check for package name conflicts in name and nicknames, then
  782. ;;; make the package.  Do a use-package for each thing in the use list
  783. ;;; so that checking for conflicting exports among used packages is done.
  784. ;;;
  785. (defun make-package (name &key (use '("LISP")) nicknames
  786.               (internal-symbols 10) (external-symbols 10))
  787.   "Makes a new package having the specified Name and Nicknames.  The
  788.   package will inherit all external symbols from each package in
  789.   the use list.  :Internal-Symbols and :External-Symbols are
  790.   estimates for the number of internal and external symbols which
  791.   will ultimately be present in the package."
  792.   (when (find-package name)
  793.     (error "A package named ~S already exists" name))
  794.   (let* ((name (string name))
  795.      (package (internal-make-package
  796.            :%name name
  797.            :internal-symbols (make-package-hashtable internal-symbols)
  798.            :external-symbols (make-package-hashtable external-symbols))))
  799.     (if *in-package-init*
  800.     (push (list use package) *deferred-use-packages*)
  801.     (use-package use package))
  802.     (enter-new-nicknames package nicknames)
  803.     (setf (gethash name *package-names*) package)))
  804.  
  805. ;;; In-Package  --  Public
  806. ;;;
  807. ;;;    Like Make-Package, only different.
  808. ;;;
  809. (defun in-package (name &rest keys &key nicknames use)
  810.   "Sets *package* to package with given name, creating the package if
  811.   it does not exist.  If the package already exists then it is modified
  812.   to agree with the :Use and :Nicknames arguments.  Any new nicknames
  813.   are added without removing any old ones not specified.  If any package
  814.   in the :Use list is not currently used, then it is added to the use
  815.   list."
  816.   (let ((package (find-package name)))
  817.     (cond
  818.      (package
  819.       (if *in-package-init*
  820.       (push (list use package) *deferred-use-packages*)
  821.       (use-package use package))
  822.       (enter-new-nicknames package nicknames)
  823.       (setq *package* package))
  824.      (t
  825.       (setq *package* (apply #'make-package name keys))))))
  826.  
  827. ;;; Rename-Package  --  Public
  828. ;;;
  829. ;;;    Change the name if we can, blast any old nicknames and then
  830. ;;; add in any new ones.
  831. ;;;
  832. (defun rename-package (package name &optional (nicknames ()))
  833.   "Changes the name and nicknames for a package."
  834.   (let* ((package (package-or-lose package))
  835.      (name (string name))
  836.      (found (find-package name)))
  837.     (unless (or (not found) (eq found package))
  838.       (error "A package named ~S already exists." name))
  839.     (remhash (package-%name package) *package-names*)
  840.     (dolist (n (package-%nicknames package))
  841.       (remhash n *package-names*))
  842.      (setf (package-%name package) name)
  843.     (setf (gethash name *package-names*) package)
  844.     (setf (package-%nicknames package) ())
  845.     (enter-new-nicknames package nicknames)
  846.     package))
  847.  
  848. ;;; List-All-Packages  --  Public
  849. ;;;
  850. ;;;
  851. (defun list-all-packages ()
  852.   "Returns a list of all existing packages."
  853.   (let ((res ()))
  854.     (maphash #'(lambda (k v)
  855.          (declare (ignore k))
  856.          (pushnew v res))
  857.          *package-names*)
  858.     res))
  859.  
  860. ;;; Intern  --  Public
  861. ;;;
  862. ;;;    Simple-stringify the name and call intern*.
  863. ;;;
  864. (defun intern (name &optional package)
  865.   "Returns a symbol having the specified name, creating it if necessary."
  866.   (let ((name (if (simple-string-p name) name (coerce name 'simple-string))))
  867.     (declare (simple-string name))
  868.     (intern* name (length name)
  869.          (if package (package-or-lose package) *package*))))
  870.  
  871. ;;; Find-Symbol  --  Public
  872. ;;;
  873. ;;;    Ditto.
  874. ;;;
  875. (defun find-symbol (name &optional package)
  876.   "Returns the symbol named String in Package.  If such a symbol is found
  877.   then the second value is :internal, :external or :inherited to indicate
  878.   how the symbol is accessible.  If no symbol is found then both values
  879.   are NIL."
  880.   (let ((name (if (simple-string-p name) name (coerce name 'simple-string))))
  881.     (declare (simple-string name))
  882.     (find-symbol* name (length name)
  883.           (if package (package-or-lose package) *package*))))
  884.  
  885. ;;; Intern*  --  Internal
  886. ;;;
  887. ;;;    If the symbol doesn't exist then create it, special-casing
  888. ;;; the keyword package.
  889. ;;;
  890. (defun intern* (name length package)
  891.   (declare (simple-string name))
  892.   (multiple-value-bind (symbol where) (find-symbol* name length package)
  893.     (if where
  894.     (values symbol where)
  895.     (let ((symbol (make-symbol (subseq name 0 length))))
  896.       (%set-symbol-package symbol package)
  897.       (cond ((eq package *keyword-package*)
  898.          (add-symbol (package-external-symbols package) symbol)
  899.          (%set-symbol-value symbol symbol))
  900.         (t
  901.          (add-symbol (package-internal-symbols package) symbol)))
  902.       (values symbol nil)))))
  903.  
  904. ;;; Find-Symbol*  --  Internal
  905. ;;;
  906. ;;;    Check internal and external symbols, then scan down the list
  907. ;;; of hashtables for inherited symbols.  When an inherited symbol
  908. ;;; is found pull that table to the beginning of the list.
  909. ;;;
  910. (defun find-symbol* (string length package)
  911.   (declare (simple-string string)
  912.        (fixnum length))
  913.   (let* ((hash (%sxhash-simple-substring string length))
  914.      (ehash (entry-hash length hash)))
  915.     (declare (fixnum hash ehash))
  916.     (with-symbol (found symbol (package-internal-symbols package)
  917.             string length hash ehash)
  918.       (when found
  919.     (return-from find-symbol* (values symbol :internal))))
  920.     (with-symbol (found symbol (package-external-symbols package)
  921.             string length hash ehash)
  922.       (when found
  923.     (return-from find-symbol* (values symbol :external))))
  924.     (let ((head (package-tables package)))
  925.       (do ((prev head table)
  926.        (table (cdr head) (cdr table)))
  927.       ((null table) (values nil nil))
  928.     (with-symbol (found symbol (car table) string length hash ehash)
  929.       (when found
  930.         (unless (eq prev head)
  931.           (shiftf (cdr prev) (cdr table) (cdr head) table))
  932.         (return-from find-symbol* (values symbol :inherited))))))))
  933.  
  934. ;;; Find-External-Symbol  --  Internal
  935. ;;;
  936. ;;;    Similar to Find-Symbol, but only looks for an external symbol.
  937. ;;; This is used for fast name-conflict checking in this file and symbol
  938. ;;; printing in the printer.
  939. ;;;
  940. (defun find-external-symbol (string package)
  941.   (declare (simple-string string))
  942.   (let* ((length (length string))
  943.      (hash (%sxhash-simple-string string))
  944.      (ehash (entry-hash length hash)))
  945.     (declare (fixnum length hash))
  946.     (with-symbol (found symbol (package-external-symbols package)
  947.             string length hash ehash)
  948.       (values symbol found))))
  949.  
  950. ;;; Unintern  --  Public
  951. ;;;
  952. ;;;    If we are uninterning a shadowing symbol, then a name conflict can
  953. ;;; result, otherwise just nuke the symbol.
  954. ;;;
  955. (defun unintern (symbol &optional (package *package*))
  956.   "Makes Symbol no longer present in Package.  If Symbol was present
  957.   then T is returned, otherwise NIL.  If Package is Symbol's home
  958.   package, then it is made uninterned."
  959.   (let* ((package (package-or-lose package))
  960.      (name (symbol-name symbol))
  961.      (shadowing-symbols (package-%shadowing-symbols package)))
  962.     (declare (list shadowing-symbols) (simple-string name))
  963.     ;;
  964.     ;; If a name conflict is revealed, give use a chance to shadowing-import
  965.     ;; one of the accessible symbols.
  966.     (when (member symbol shadowing-symbols)
  967.       (let ((cset ()))
  968.     (dolist (p (package-%use-list package))
  969.       (multiple-value-bind (s w) (find-external-symbol name p)
  970.         (when w (pushnew s cset))))
  971.     (when (cdr cset)
  972.       (loop
  973.        (cerror
  974.         "prompt for a symbol to shadowing-import."
  975.         "Uninterning symbol ~S causes name conflict among these symbols:~%~S"
  976.         symbol cset)
  977.        (write-string "Symbol to shadowing-import: " *query-io*)
  978.        (let ((sym (read *query-io*)))
  979.          (cond
  980.           ((not (symbolp sym))
  981.            (format *query-io* "~S is not a symbol."))
  982.           ((not (member sym cset))
  983.            (format *query-io* "~S is not one of the conflicting symbols."))
  984.           (t
  985.            (shadowing-import sym package)
  986.            (return-from unintern t)))))))
  987.       (setf (package-%shadowing-symbols package)
  988.         (remove symbol shadowing-symbols)))
  989.  
  990.     (multiple-value-bind (s w) (find-symbol name package)
  991.       (declare (ignore s))
  992.       (cond ((or (eq w :internal) (eq w :external))
  993.          (nuke-symbol (if (eq w :internal)
  994.                   (package-internal-symbols package)
  995.                   (package-external-symbols package))
  996.               name)
  997.          (if (eq (symbol-package symbol) package)
  998.          (%set-symbol-package symbol nil))
  999.          t)
  1000.         (t nil)))))
  1001.  
  1002. ;;; Symbol-Listify  --  Internal
  1003. ;;;
  1004. ;;;    Take a symbol-or-list-of-symbols and return a list, checking types.
  1005. ;;;
  1006. (defun symbol-listify (thing)
  1007.   (cond ((listp thing)
  1008.      (dolist (s thing)
  1009.        (unless (symbolp s) (error "~S is not a symbol." s)))
  1010.      thing)
  1011.     ((symbolp thing) (list thing))
  1012.     (t
  1013.      (error "~S is neither a symbol nor a list of symbols." thing))))
  1014.  
  1015. ;;; Moby-Unintern  --  Internal
  1016. ;;;
  1017. ;;;    Like Unintern, but if symbol is inherited chases down the
  1018. ;;; package it is inherited from and uninterns it there.  Used
  1019. ;;; for name-conflict resolution.  Shadowing symbols are not
  1020. ;;; uninterned since they do not cause conflicts.
  1021. ;;;
  1022. (defun moby-unintern (symbol package)
  1023.   (unless (member symbol (package-%shadowing-symbols package))
  1024.     (or (unintern symbol package)
  1025.     (let ((name (symbol-name symbol)))
  1026.       (multiple-value-bind (s w) (find-symbol name package)
  1027.         (declare (ignore s))
  1028.         (when (eq w :inherited)
  1029.           (dolist (q (package-%use-list package))
  1030.         (multiple-value-bind (u x) (find-external-symbol name q)
  1031.           (declare (ignore u))
  1032.           (when x
  1033.             (unintern symbol q)
  1034.             (return t))))))))))
  1035.  
  1036. ;;; Export  --  Public
  1037. ;;;
  1038. ;;;    Do more stuff.
  1039. ;;;
  1040. (defun export (symbols &optional (package *package*))
  1041.   "Exports Symbols from Package, checking that no name conflicts result."
  1042.   (let ((package (package-or-lose package))
  1043.     (syms ()))
  1044.     ;;
  1045.     ;; Punt any symbols that are already external.
  1046.     (dolist (sym (symbol-listify symbols))
  1047.       (multiple-value-bind (s w)
  1048.                (find-external-symbol (symbol-name sym) package)
  1049.     (declare (ignore s))
  1050.     (unless (or w (member sym syms)) (push sym syms))))
  1051.     ;;
  1052.     ;; Find symbols and packages with conflicts.
  1053.     (let ((used-by (package-%used-by-list package))
  1054.       (cpackages ())
  1055.       (cset ()))
  1056.       (dolist (sym syms)
  1057.     (let ((name (symbol-name sym)))
  1058.       (dolist (p used-by)
  1059.         (multiple-value-bind (s w) (find-symbol name p)
  1060.           (when (and w (not (eq s sym))
  1061.              (not (member s (package-%shadowing-symbols p))))
  1062.         (pushnew sym cset)
  1063.         (pushnew p cpackages))))))
  1064.       (when cset
  1065.     (restart-case
  1066.         (error "Exporting these symbols from the ~A package:~%~S~%~
  1067.             results in name conflicts with these packages:~%~{~A ~}"
  1068.            (package-%name package) cset (mapcar #'package-%name cpackages))
  1069.       (unintern-conflicting-symbols ()
  1070.        :report "Unintern conflicting symbols."
  1071.        (dolist (p cpackages)
  1072.          (dolist (sym cset)
  1073.            (moby-unintern sym p))))
  1074.       (skip-exporting-these-symbols ()
  1075.        :report "Skip exporting conflicting symbols."
  1076.        (setq syms (nset-difference syms cset))))))
  1077.     ;;
  1078.     ;; Check that all symbols are accessible.  If not, ask to import them.
  1079.     (let ((missing ())
  1080.       (imports ()))
  1081.       (dolist (sym syms)
  1082.     (multiple-value-bind (s w) (find-symbol (symbol-name sym) package)
  1083.       (cond ((not (and w (eq s sym))) (push sym missing))
  1084.         ((eq w :inherited) (push sym imports)))))
  1085.       (when missing
  1086.     (cerror "Import these symbols into the ~A package."
  1087.         "These symbols are not accessible in the ~A package:~%~S"
  1088.         (package-%name package) missing)
  1089.     (import missing package))
  1090.       (import imports package))
  1091.     ;;
  1092.     ;; And now, three pages later, we export the suckers.
  1093.     (let ((internal (package-internal-symbols package))
  1094.       (external (package-external-symbols package)))
  1095.       (dolist (sym syms)
  1096.     (nuke-symbol internal (symbol-name sym))
  1097.     (add-symbol external sym)))
  1098.     t))
  1099.  
  1100. ;;; Unexport  --  Public
  1101. ;;;
  1102. ;;;    Check that all symbols are accessible, then move from external to
  1103. ;;; internal.
  1104. ;;;
  1105. (defun unexport (symbols &optional (package *package*))
  1106.   "Makes Symbols no longer exported from Package."
  1107.   (let ((package (package-or-lose package))
  1108.     (syms ()))
  1109.     (dolist (sym (symbol-listify symbols))
  1110.       (multiple-value-bind (s w) (find-symbol (symbol-name sym) package)
  1111.     (cond ((or (not w) (not (eq s sym)))
  1112.            (error "~S is not accessible in the ~A package."
  1113.               sym (package-%name package)))
  1114.           ((eq w :external) (pushnew sym syms)))))
  1115.  
  1116.     (let ((internal (package-internal-symbols package))
  1117.       (external (package-external-symbols package)))
  1118.       (dolist (sym syms)
  1119.     (add-symbol internal sym)
  1120.     (nuke-symbol external (symbol-name sym))))
  1121.     t))
  1122.  
  1123. ;;; Import  --  Public
  1124. ;;;
  1125. ;;;    Check for name conflic caused by the import and let the user 
  1126. ;;; shadowing-import if there is.
  1127. ;;;
  1128. (defun import (symbols &optional (package *package*))
  1129.   "Make Symbols accessible as internal symbols in Package.  If a symbol
  1130.   is already accessible then it has no effect.  If a name conflict
  1131.   would result from the importation, then a correctable error is signalled."
  1132.   (let ((package (package-or-lose package))
  1133.     (symbols (symbol-listify symbols))
  1134.     (syms ())
  1135.     (cset ()))
  1136.     (dolist (sym symbols)
  1137.       (multiple-value-bind (s w) (find-symbol (symbol-name sym) package)
  1138.     (cond ((not w)
  1139.            (let ((found (member sym syms :test #'string=)))
  1140.          (if found
  1141.              (when (not (eq (car found) sym))
  1142.                (push sym cset))
  1143.              (push sym syms))))
  1144.           ((not (eq s sym)) (push sym cset))
  1145.           ((eq w :inherited) (push sym syms)))))
  1146.     (when cset
  1147.       (cerror
  1148.        "Import these symbols with Shadowing-Import."
  1149.        "Importing these symbols into the ~A package causes a name conflict:~%~S"
  1150.        (package-%name package) cset))
  1151.     ;;
  1152.     ;; Add the new symbols to the internal hashtable.
  1153.     (let ((internal (package-internal-symbols package)))
  1154.       (dolist (sym syms)
  1155.     (add-symbol internal sym)))
  1156.     ;;
  1157.     ;; If any of the symbols are uninterned, make them be owned by Package.
  1158.     (dolist (sym symbols)
  1159.       (unless (symbol-package sym) (%set-symbol-package sym package)))
  1160.     (shadowing-import cset package)))
  1161.  
  1162. ;;; Shadowing-Import  --  Public
  1163. ;;;
  1164. ;;;    If a conflicting symbol is present, unintern it, otherwise just
  1165. ;;; stick the symbol in.
  1166. ;;;
  1167. (defun shadowing-import (symbols &optional (package *package*))
  1168.   "Import Symbols into package, disregarding any name conflict.  If
  1169.   a symbol of the same name is present, then it is uninterned.
  1170.   The symbols are added to the Package-Shadowing-Symbols."
  1171.   (let* ((package (package-or-lose package))
  1172.      (internal (package-internal-symbols package)))
  1173.     (dolist (sym (symbol-listify symbols))
  1174.       (multiple-value-bind (s w) (find-symbol (symbol-name sym) package)
  1175.     (unless (and w (not (eq w :inherited)) (eq s sym))
  1176.       (when (or (eq w :internal) (eq w :external))
  1177.         ;;
  1178.         ;; If it was shadowed, we don't want Unintern to flame out...
  1179.         (setf (package-%shadowing-symbols package)
  1180.           (remove s (the list (package-%shadowing-symbols package))))
  1181.         (unintern s package))
  1182.       (add-symbol internal sym))
  1183.     (pushnew sym (package-%shadowing-symbols package)))))
  1184.   t)
  1185.  
  1186.  
  1187. ;;; Shadow  --  Public
  1188. ;;;
  1189. ;;;
  1190. (defun shadow (symbols &optional (package *package*))
  1191.   "Make an internal symbol in Package with the same name as each of the
  1192.   specified symbols, adding the new symbols to the Package-Shadowing-Symbols.
  1193.   If a symbol with the given name is already present in Package, then
  1194.   the existing symbol is placed in the shadowing symbols list if it is
  1195.   not already present."
  1196.   (let* ((package (package-or-lose package))
  1197.      (internal (package-internal-symbols package)))
  1198.     (dolist (name (mapcar #'string
  1199.               (if (listp symbols) symbols (list symbols))))
  1200.       (multiple-value-bind (s w) (find-symbol name package)
  1201.     (when (or (not w) (eq w :inherited))
  1202.       (setq s (make-symbol name))
  1203.       (%set-symbol-package s package)
  1204.       (add-symbol internal s))
  1205.     (pushnew s (package-%shadowing-symbols package))))))
  1206.   t)
  1207.  
  1208. ;;; Use-Package  --  Public
  1209. ;;;
  1210. ;;;    Do stuff to use a package, with all kinds of fun name-conflict
  1211. ;;; checking.
  1212. ;;;
  1213. (defun use-package (packages-to-use &optional (package *package*))
  1214.   "Add all the Package-To-Use to the use list for Package so that
  1215.   the external symbols of the used packages are accessible as internal
  1216.   symbols in Package."
  1217.   (let ((packages (package-listify packages-to-use))
  1218.     (package (package-or-lose package)))
  1219.     ;;
  1220.     ;; Loop over each package, use'ing one at a time...
  1221.     (dolist (pkg packages)
  1222.       (unless (member pkg (package-%use-list package))
  1223.     (let ((cset ())
  1224.           (shadowing-symbols (package-%shadowing-symbols package))
  1225.           (use-list (package-%use-list package)))
  1226.       ;;
  1227.       ;;   If the number of symbols already accessible is less than the
  1228.       ;; number to be inherited then it is faster to run the test the
  1229.       ;; other way.  This is particularly valuable in the case of
  1230.       ;; a new package use'ing Lisp.
  1231.       (cond
  1232.        ((< (+ (internal-symbol-count package)
  1233.           (external-symbol-count package)
  1234.           (let ((res 0))
  1235.             (dolist (p use-list res)
  1236.               (incf res (external-symbol-count p)))))
  1237.            (external-symbol-count pkg))
  1238.         (do-symbols (sym package)
  1239.           (multiple-value-bind (s w)
  1240.                    (find-external-symbol (symbol-name sym) pkg)
  1241.         (when (and w (not (eq s sym))
  1242.                (not (member sym shadowing-symbols)))
  1243.           (push sym cset))))
  1244.         (dolist (p use-list)
  1245.           (do-external-symbols (sym p)
  1246.         (multiple-value-bind (s w)
  1247.                      (find-external-symbol (symbol-name sym)
  1248.                                pkg)
  1249.           (when (and w (not (eq s sym))
  1250.                  (not (member (find-symbol (symbol-name sym)
  1251.                                package)
  1252.                       shadowing-symbols)))
  1253.             (push sym cset))))))
  1254.        (t
  1255.         (do-external-symbols (sym pkg)
  1256.           (multiple-value-bind (s w)
  1257.                    (find-symbol (symbol-name sym) package)
  1258.         (when (and w (not (eq s sym))
  1259.                (not (member s shadowing-symbols)))
  1260.           (push s cset))))))
  1261.       
  1262.       (when cset
  1263.         (cerror
  1264.          "unintern the conflicting symbols in the ~2*~A package."
  1265.          "Use'ing package ~A results in name conflicts for these symbols:~%~S"
  1266.          (package-%name pkg) cset (package-%name package))
  1267.         (dolist (s cset) (moby-unintern s package))))
  1268.  
  1269.     (push pkg (package-%use-list package))
  1270.     (push (package-external-symbols pkg) (cdr (package-tables package)))
  1271.     (push package (package-%used-by-list pkg)))))
  1272.   t)
  1273.  
  1274. ;;; Unuse-Package  --  Public
  1275. ;;;
  1276. ;;;
  1277. (defun unuse-package (packages-to-unuse &optional (package *package*))
  1278.   "Remove Packages-To-Unuse from the use list for Package."
  1279.   (let ((package (package-or-lose package)))
  1280.     (dolist (p (package-listify packages-to-unuse))
  1281.       (setf (package-%use-list package)
  1282.         (remove p (the list (package-%use-list package))))
  1283.       (setf (package-tables package)
  1284.         (delete (package-external-symbols p)
  1285.             (the list (package-tables package))))
  1286.       (setf (package-%used-by-list p)
  1287.         (remove package (the list (package-%used-by-list p)))))
  1288.     t))
  1289.  
  1290. ;;; Find-All-Symbols --  Public
  1291. ;;;
  1292. ;;;
  1293. (defun find-all-symbols (string-or-symbol)
  1294.   "Return a list of all symbols in the system having the specified name."
  1295.   (let ((string (string string-or-symbol))
  1296.     (res ()))
  1297.     (maphash #'(lambda (k v)
  1298.          (declare (ignore k))
  1299.          (multiple-value-bind (s w) (find-symbol string v)
  1300.            (when w (pushnew s res))))
  1301.          *package-names*)
  1302.     res))
  1303.  
  1304.  
  1305. ;;; Apropos and Apropos-List.
  1306.  
  1307. (defun briefly-describe-symbol (symbol)
  1308.   (fresh-line)
  1309.   (prin1 symbol)
  1310.   (when (boundp symbol)
  1311.     (write-string ", value: ")
  1312.     (prin1 (symbol-value symbol)))
  1313.   (if (fboundp symbol)
  1314.       (write-string " (defined)")))
  1315.  
  1316. (defun apropos-search (symbol string)
  1317.   (declare (simple-string string))
  1318.   (do* ((index 0 (1+ index))
  1319.     (name (symbol-name symbol))
  1320.     (length (length string))
  1321.     (terminus (- (length name) length)))
  1322.        ((> index terminus)
  1323.     nil)
  1324.     (declare (simple-string name)
  1325.          (fixnum index terminus length))
  1326.     (if (do ((jndex 0 (1+ jndex))
  1327.          (kndex index (1+ kndex)))
  1328.         ((= jndex length)
  1329.          t)
  1330.       (declare (fixnum jndex kndex))
  1331.       (let ((char (schar name kndex)))
  1332.         (unless (char= (schar string jndex) (char-upcase char))
  1333.           (return nil))))
  1334.     (return t))))
  1335.  
  1336. (defun apropos (string &optional package external-only)
  1337.   "Briefly describe all symbols which contain the specified String.
  1338.   If Package is supplied then only describe symbols present in
  1339.   that package.  If External-Only is true then only describe
  1340.   external symbols in the specified package."
  1341.   (let ((string (string-upcase string)))
  1342.     (declare (simple-string string))
  1343.     (if (null package)
  1344.     (do-all-symbols (symbol)
  1345.        (if (apropos-search symbol string)
  1346.            (briefly-describe-symbol symbol)))
  1347.     (let ((package (package-or-lose package)))
  1348.       (if external-only
  1349.           (do-external-symbols (symbol package)
  1350.         (if (apropos-search symbol string)
  1351.             (briefly-describe-symbol symbol)))
  1352.           (do-symbols (symbol package)
  1353.         (if (apropos-search symbol string)
  1354.             (briefly-describe-symbol symbol))))))
  1355.     (values)))
  1356.  
  1357. (defun apropos-list (string &optional package external-only)
  1358.   "Identical to Apropos, except that it returns a list of the symbols
  1359.   found instead of describing them."
  1360.   (let ((string (string-upcase string))
  1361.     (list '()))
  1362.     (declare (simple-string string))
  1363.     (if (null package)
  1364.     (do-all-symbols (symbol)
  1365.        (if (apropos-search symbol string)
  1366.            (push symbol list)))
  1367.     (let ((package (package-or-lose package)))
  1368.       (if external-only
  1369.           (do-external-symbols (symbol package)
  1370.         (if (apropos-search symbol string)
  1371.             (push symbol list)))
  1372.           (do-symbols (symbol package)
  1373.         (if (apropos-search symbol string)
  1374.             (push symbol list))))))
  1375.     list))
  1376.  
  1377. ;;; Initialization.
  1378.  
  1379. ;;; The cold loader (Genesis) makes the data structure in *initial-symbols*.
  1380. ;;; We grovel over it, making the specified packages and interning the
  1381. ;;; symbols.  For a description of the format of *initial-symbols* see
  1382. ;;; the Genesis source.
  1383.  
  1384. (defvar *initial-symbols*)
  1385.  
  1386. (defun package-init ()
  1387.   (let ((*in-package-init* t))
  1388.     (dolist (spec *initial-symbols*)
  1389.       (let* ((pkg (apply #'make-package (first spec)))
  1390.          (internal (package-internal-symbols pkg))
  1391.          (external (package-external-symbols pkg)))
  1392.     ;;
  1393.     ;; Put internal symbols in the internal hashtable and set package.
  1394.     (dolist (symbol (second spec))
  1395.       (add-symbol internal symbol)
  1396.       (%set-symbol-package symbol pkg))
  1397.     ;;
  1398.     ;; External symbols same, only go in external table.
  1399.     (dolist (symbol (third spec))
  1400.       (add-symbol external symbol)
  1401.       (%set-symbol-package symbol pkg))
  1402.     ;;
  1403.     ;; Don't set package for Imported symbols.
  1404.     (dolist (symbol (fourth spec))
  1405.       (add-symbol internal symbol))
  1406.     (dolist (symbol (fifth spec))
  1407.       (add-symbol external symbol))
  1408.     ;;
  1409.     ;; Put shadowing symbols in the shadowing symbols list.
  1410.     (setf (package-%shadowing-symbols pkg) (sixth spec))))
  1411.  
  1412.     (makunbound '*initial-symbols*) ; So it gets GC'ed.
  1413.     
  1414.     ;; Make some other packages that should be around in the cold load:
  1415.     (make-package "COMMON-LISP-USER" :nicknames '("CL-USER" "USER"))
  1416.  
  1417.     ;; Now do the *deferred-use-packages*:
  1418.     (dolist (args *deferred-use-packages*)
  1419.       (apply #'use-package args))
  1420.     (makunbound '*deferred-use-packages*)
  1421.  
  1422.     (setq *lisp-package* (find-package "LISP"))
  1423.     (setq *keyword-package* (find-package "KEYWORD"))
  1424.  
  1425.     ;; For the kernel core image wizards, set the package to *Lisp-Package*.
  1426.     (setq *package* *lisp-package*)))
  1427.